Cream of the Crop 20/Cream of the Crop 20 (Terry Blount) (1996).iso/program/pcl4p51.zip/SIMPLE16.PAS

Pascal/Delphi Source File | 1996-06-05 | 6KB | 189 lines

(*********************************************)
(*                                           *)
(*        SIMPLE16.PAS      June 96          *)
(*                                           *)
(*    16-bit DPMI Protected Mode Version     *)
(*    Compile:  BPC /CP SIMPLE16             *)
(*                                           *)
(*  This program is donated to the Public    *)
(*  Domain by MarshallSoft Computing, Inc.   *)
(*  It is provided as an example of the use  *)
(*  of the Personal Communications Library.  *)
(*                                           *)
(*********************************************)


program simple;
uses crt, WinAPI, PCL4P16, use_dpmi;

var
   BaudCode : Integer;
   RetCode  : Integer;
   Byte : Char;
   i    : Integer;
   Port : Integer;
   ResetFlag : Boolean;
   Handle    : LongInt;
   RxSelector  : Integer;
   TxSelector  : Integer;
   DPMIversion : LongInt;

procedure SayError( Code : Integer );
var
   RetCode : Integer;
begin
   if Code < 0 then RetCode := SioError( Code )
   else if (Code and (FramingError or ParityError or OverrunError)) <> 0 then
      begin (* Port Error *)
         if (Code and FramingError) <> 0 then writeln('Framing Error');
         if (Code and ParityError)  <> 0 then writeln('Parity Error');
         if (Code and OverrunError) <> 0 then writeln('Overrun Error')
      end
end;

procedure MyHalt( Code : Integer );
var
   RetCode : Integer;
begin
   if Code < 0 then SayError( Code );
   if ResetFlag then RetCode := SioDone(Port);
   writeln('*** HALTING ***');
   Halt;
end;

function MatchBaud(BaudString : String) : Integer;
const
   BaudRateArray : array[1..10] of LongInt =
       (300,600,1200,2400,4800,9600,19200,38400,57600,115200);
var
   i : Integer;
   BaudRate: LongInt;
   RetCode : Integer;
begin
  Val(BaudString,BaudRate,RetCode);
  if RetCode <> 0 then
  begin
    MatchBaud := -1;
    exit;
  end;
  for i := 1 to 10 do if BaudRateArray[i] = BaudRate then
  begin
    MatchBaud := i - 1;
    exit;
  end;
  (* no match *)
  MatchBaud := -1;
end;

begin   (* main program *)
   ResetFlag := FALSE;
   RxSelector := 0;
   TxSelector := 0;
   (* fetch PORT # from command line *)
   if ParamCount <> 2 then
      begin
         writeln('USAGE: "SIMPLE16 <port> <baud rate>" where port = 1 to 20');
         halt;
      end;
   Val( ParamStr(1),Port, RetCode );
   if RetCode <> 0 then
      begin
         writeln('Port must be 1 to 20');
         Halt;
      end;
   (* COM1 = 0, COM2 = 1, etc. *)
   Port := Port - 1;
   if (Port<COM1) or (Port>COM20) then
      begin
         writeln('Port must be 1 to 20');
         Halt
      end;
   (* get baud rate *)
   BaudCode := MatchBaud(ParamStr(2));
   DPMIversion := LOWORD( DPMI_GetVersion );
   writeln('DPMI version ', (DPMIversion SHR 8),'.',(255 and DPMIversion) );
   (* setup 1K receive buffer in DOS memory *)
   Handle := GlobalDosAlloc(1024);
   RxSelector :=  LOWORD(Handle);
   RetCode := SioRxBuf(Port, RxSelector, Size1024);
   if RetCode < 0 then MyHalt( RetCode );
   if SioInfo('I') > 0 then
     begin
       (* setup 128 transmit buffer in DOS memory *)
       Handle := GlobalDosAlloc(128);
       TxSelector := LOWORD(Handle);
       RetCode := SioTxBuf(Port, TxSelector, Size128);
       if RetCode < 0 then MyHalt( RetCode );
     end;
   (* reset port *)
   RetCode := SioReset(Port,BaudCode);
   (* if error then try one more time *)
   if RetCode <> 0 then RetCode := SioReset(Port,BaudCode);
   (* Was port reset ? *)
   if RetCode <> 0 then
     begin
        writeln('Cannot reset COM',Port+1);
        MyHalt( RetCode );
     end;
   (* Port successfully reset *)
   writeln;
   writeln('COM',1+Port,' @ ',ParamStr(2));

   (* display DPMI version *)
   DPMIversion := LOWORD( DPMI_GetVersion );
   writeln('DPMI version ', (DPMIversion SHR 8),'.',(255 and DPMIversion) );
   ResetFlag := TRUE;
   (* specify parity, # stop bits, and word length for port *)
   RetCode := SioParms(Port, NoParity, OneStopBit, WordLength8);
   if RetCode < 0 then MyHalt( RetCode );

   (* set FIFO level if have INS16550 *)
   RetCode := SioFIFO(Port, LEVEL_8);
   if RetCode < 0 then MyHalt( RetCode );

   RetCode := SioRxClear(Port);
   if RetCode < 0 then MyHalt( RetCode );

   (* set DTR & RTS *)
   RetCode := SioDTR(Port,SetPort);
   RetCode := SioRTS(Port,SetPort);
   (* begin terminal loop *)
   writeln('Enter terminal loop ( Type ^Z to exit )');
   while TRUE do
      begin
         (* did user press Ctrl-BREAK ? *)
         if SioBrkKey then
            begin
               writeln('User typed Ctl-BREAK');
               RetCode := SioDone(Port);
               Halt;
            end;
         (* check for data overrun *)
         if (SioLine(Port) AND OverrunError) <> 0 then writeln('Overrun!');
         (* anything incoming over serial port ? *)
         RetCode := SioGetc(Port,0);
         if RetCode < -1 then MyHalt( RetCode );
         if RetCode > -1 then Write( chr(RetCode) );
         (* has user pressed keyboard ? *)
         if KeyPressed then
            begin
               (* read keyboard *)
               Byte := ReadKey;
               (* quit if user types ^Z *)
               if Byte = chr($1a) then
                  begin
                     writeln('User typed ^Z');
                     RetCode := SioDone(Port);
                     (* free DOS memory *)
                     if RxSelector <> 0 then GlobalDosFree(RxSelector);
                     if TxSelector <> 0 then GlobalDosFree(TxSelector);
                     Halt;
                  end;
               (* send out over serial line *)
               RetCode := SioPutc(Port, Byte );
               if RetCode < 0 then MyHalt( RetCode );
            end
      end
end.